unit CPOpenGLFont;

interface

uses Windows, OpenGL_SG, Graphics, Types;

//{$DEFINE FONT_DEBUG}

const
  { Gllyph padding for layout of glyphs on the created glyph texture.
    Horizontal (or vertical) padding will be added as additional space in
    pixel on the left and right (or top and bottom) side of the glyph.
    This used to compensate the additional pixels used by a glyph, when
    Cleartype is turned on. }
  GlyphPad: TPoint = (X:1; Y:0);
  { Maximum width of the glyph texture }
  MaxMapWidth = 1024;

type
  { Allows to render text in OpenGL using a Windows vector font }
  TCPOpenGLFont = class
  private
    { Font that is used }
    FFont: TFont;
    { OpenGL name of texture containing glyphs }
    FTexture: GLint;
    { Index of the first of FListCount display lists for rendering glyphs }
    FListIndex: GLint;
    { Number of display lists for rendering glyphs }
    FListCount: Integer;
    { First glyph in the interval of drawable glyphs }
    FFirstGlyph: Char;
    { Last glyph in the interval of drawable glyphs }
    FLastGlyph: Char;
    { Number of drawable glyphs }
    FGlyphCount: Integer;
    { List with layout of all glyphs on the glyph bitmap }
    FGlyphPositions: array of TRect;
    { Kerning table for pairs of glyphs }
    FKerningTable: array of TByteDynArray;
    { Width information for all glyphs }
    FABCWidths: array of TABC;
    { Glyph map, on which glyphs are drawn }
    FGlyphMap: TBitmap;
    procedure SetFont(const Value: TFont);
    procedure DrawGlyphMap(GlyphMap: TBitmap; TextureSize: TSize);
    procedure BuildABCWidths(Canvas: TCanvas);
    function BuildGlyphPositions(Canvas: TCanvas): TSize;
    procedure BuildKerningTable(Canvas: TCanvas);
    procedure BuildFont;
    procedure BuildDisplayLists;
    procedure FreeDisplayLists;
    procedure FreeKerningTable;
    procedure UpdateGlyphCount;
    procedure SetFirstGlyph(const Value: Char);
    procedure SetLastGlyph(const Value: Char);
    { Rounds up to the next power of 2 number and returns it. If Value already
      is a power of two number than it is returned. }
    function RoundToPowerOfTwo(Value: Integer): Integer;
    { Renders a single character using the glyph texture }
    procedure DrawCharacter(C: Char);
  public
    constructor Create;
    destructor Destroy; override;
    { Used font }
    property Font: TFont read FFont write SetFont;
    property FirstGlyph: Char read FFirstGlyph write SetFirstGlyph;
    property LastGlyph: Char read FLastGlyph write SetLastGlyph;
    property GlyphCount: Integer read FGlyphCount;
    procedure DrawText(X, Y: Single; Text: string; Color: TColor);
  end;

implementation

uses SysUtils, Math;

{ TCPOpenGLFont }

procedure TCPOpenGLFont.BuildABCWidths(Canvas: TCanvas);
begin
  SetLength(FABCWidths, FGlyphCount);
  GetCharABCWidths(Canvas.Handle, Ord(FFirstGlyph), Ord(FLastGlyph),
    FABCWidths[0]);
end;

procedure TCPOpenGLFont.BuildDisplayLists;
var
  C: Char;
begin
  FreeDisplayLists;
  FListIndex := glGenLists(FGlyphCount);
  FListCount := FGlyphCount;
  for C := FFirstGlyph to FLastGlyph do
  begin
    glNewList(FListIndex + Ord(C) - Ord(FFirstGlyph), GL_COMPILE);
    DrawCharacter(C);
    glEndList;
  end;
end;

procedure TCPOpenGLFont.BuildFont;
var
  TextureSize: TSize;
begin
  FGlyphMap := TBitmap.Create;
  FGlyphMap.PixelFormat := pf32bit;
  FGlyphMap.Canvas.Font := FFont;
  BuildABCWidths(FGlyphMap.Canvas);
  TextureSize := BuildGlyphPositions(FGlyphMap.Canvas);
  DrawGlyphMap(FGlyphMap, TextureSize);
  //BuildKerningTable(Canvas);
  // Generate texture:
  glDeleteTextures(1, @FTexture);
  glGenTextures(1, @FTexture);
  glBindTexture(GL_TEXTURE_2D, FTexture);
  glTexImage2D(GL_TEXTURE_2D, 0, 4, FGlyphMap.Width, FGlyphMap.Height, 0,
    GL_BGRA, GL_UNSIGNED_BYTE, FGlyphMap.ScanLine[FGlyphMap.Height - 1]);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
  BuildDisplayLists;
  FGlyphMap.Free;
  Finalize(FABCWidths);
  Finalize(FGlyphPositions);
end;

function TCPOpenGLFont.BuildGlyphPositions(Canvas: TCanvas): TSize;
var
  GP: ^TRect;
  C: Char;
  RowHeight, CharWidth: Integer;
  Cursor: TPoint;
  TextMetric: TTextMetric;
  ABC: ^TABC;
begin
  SetLength(FGlyphPositions, FGlyphCount);
  GP := @(FGlyphPositions[0]);
  Result.cx := 0;
  Cursor := Point(0, 0);
  GetTextMetrics(Canvas.Handle, TextMetric);
  RowHeight := TextMetric.tmHeight + GlyphPad.Y * 2;
  // Layout glyphs on bitmap
  for C := FFirstGlyph to FLastGlyph do
  begin
    ABC := @FABCWidths[Ord(C) - Ord(FFirstGlyph)];
    CharWidth := Integer(ABC.abcB) + GlyphPad.X * 2;
    if (Cursor.X + CharWidth > MaxMapWidth) then
    begin
      Result.cx := Max(Cursor.X, Result.cx);
      Inc(Cursor.Y, RowHeight);
      Cursor.X := 0;
    end;
    GP^.TopLeft := Cursor;
    GP^.BottomRight := Point(Cursor.X + CharWidth, Cursor.Y + RowHeight);
    Inc(GP);
    Inc(Cursor.X, CharWidth);
    // Check if there is horizontal space for next character:
  end;
  if Result.cx = 0 then
    Result.cx := Cursor.X;
  Result.cx := RoundToPowerOfTwo(Result.cx);
  Result.cy := RoundToPowerOfTwo(Cursor.Y + RowHeight);
end;

procedure TCPOpenGLFont.BuildKerningTable(Canvas: TCanvas);
var
  Count, I, J: Integer;
  KerningPairs: array of TKerningPair;
  Pair: PKerningPair;
begin
  FreeKerningTable;
  Count := GetKerningPairs(Canvas.Handle, 0, PKerningPair(nil)^);
  SetLength(KerningPairs, Count);
  GetKerningPairs(Canvas.Handle, Length(KerningPairs), KerningPairs[0]);
  SetLength(FKerningTable, FGlyphCount);
  FillChar(FKerningTable[0], Length(FKerningTable) * SizeOf(FKerningTable[0]), 0);
  for I := Low(KerningPairs) to High(KerningPairs) do
  begin
    Pair := @KerningPairs[I];
    if (Pair.wFirst >= Ord(FFirstGlyph)) and
      (Pair.wFirst <= Ord(FLastGlyph)) and
      (Pair.wSecond >= Ord(FFirstGlyph)) and
      (Pair.wSecond <= Ord(FLastGlyph)) and (Pair.iKernAmount <> 0) then
    begin
      J := Pair.wFirst - Ord(FFirstGlyph);
      if (Length(FKerningTable[J]) = 0) then
      begin
        SetLength(FKerningTable[J], FGlyphCount);
        FillChar(FKerningTable[J][0], Length(FKerningTable[J]) * SizeOf(FKerningTable[J][0]), 0);
      end;
      //FillChar(FKerningTable[J], SizeOf(FKerningTable[J][0]) * Length(FKerningTable[J]), 0);
      FKerningTable[J][Pair.wSecond - Ord(FFirstGlyph)] := Pair.iKernAmount;
    end;
  end;
  Finalize(KerningPairs);
end;

constructor TCPOpenGLFont.Create;
begin
  FFont := nil;
  FTexture := 0;
  FGlyphMap := nil;
  FGlyphPositions := nil;
  FABCWidths := nil;
  FListIndex := -1;
  FListCount := 0;
end;


procedure TCPOpenGLFont.DrawGlyphMap(GlyphMap: TBitmap; TextureSize: TSize);
var
  Canvas: TCanvas;
  C: Char;
  GP: ^TRect;
  Offset, EndOffset: PInteger;
type
  TChannels = array[0..3] of Byte;
begin
  GlyphMap.Width := TextureSize.cx;
  GlyphMap.Height := TextureSize.cy;
  Canvas := GlyphMap.Canvas;
  // Draw glyphs on bitmap
  Canvas.Font := FFont;
  Canvas.Font.Color := clWhite;
  Canvas.Brush.Color := clBlack;
  Canvas.FillRect(Canvas.ClipRect);
  Canvas.Brush.Style := bsClear;
  GP := @(FGlyphPositions[0]);
  for C := FirstGlyph to LastGlyph do
  begin
    {$IFDEF FONT_DEBUG}
    Canvas.Pen.Color := Integer(Random($FFFFFF)) or $202020;
    Canvas.Rectangle(GP.Left, GP.Top, GP.Right, GP.Bottom);
    {$ENDIF}
    Canvas.TextOut(GP^.Left + GlyphPad.X -
      FABCWidths[Ord(C) - Ord(FFirstGlyph)].abcA, GP^.Top + GlyphPad.Y, C);
    Inc(GP);
  end;
  {$IFDEF FONT_DEBUG}
    FGlyphMap.SaveToFile('C:\test.bmp');
  {$ENDIF}
  // Convert cleartpye glyphs to grayscale and write alpha channel:
  Offset := GlyphMap.ScanLine[GlyphMap.Height - 1];
  EndOffset := GlyphMap.ScanLine[0];
  Inc(EndOffset, GlyphMap.Width - 1);
  while Integer(Offset) < Integer(EndOffset) do
  begin
    Offset^ := (Trunc(TChannels(Offset^)[0] * 0.114 +
       TChannels(Offset^)[1] * 0.587 + TChannels(Offset^)[2] * 0.299)) shl 24
       or $FFFFFF;
    Inc(Offset);
  end;
end;

destructor TCPOpenGLFont.Destroy;
begin
  FreeKerningTable;
  glDeleteTextures(1, @FTexture);
  inherited;
end;

procedure TCPOpenGLFont.DrawCharacter(C: Char);
var
  R: PRect;
  U1, V1, U2, V2: Single;
  I: Integer;
begin
  if not InRange(Ord(C), Ord(FFirstGlyph), ORd(FLastGlyph)) then
    C := FLastGlyph;
  I := Ord(C) - Ord(FFirstGlyph);
  R := @(FGlyphPositions[I]);
  U1 := (R.Left) / FGlyphMap.Width;
  V1 := 1 - (R.Top) / FGlyphMap.Height;
  U2 := (R.Right) / FGlyphMap.Width;
  V2 := 1 - (R.Bottom) / FGlyphMap.Height;
  glTranslated(FABCWidths[I].abcA - GlyphPad.X, 0.0, 0.0);
  glBegin(GL_QUADS);
    glTexCoord2f(U1, V1);
    glVertex2f(0.0, 0.0);
    glTexCoord2f(U2, V1);
    glVertex2f(R.Right - R.Left, 0.0);
    glTexCoord2f(U2, V2);
    glVertex2f(R.Right - R.Left, R.Bottom - R.Top);
    glTexCoord2f(U1, V2);
    glVertex2f(0.0, R.Bottom - R.Top);
  glEnd;
  glTranslated(R.Right - R.Left + FABCWidths[I].abcC - GlyphPad.X, 0.0, 0.0);
end;

procedure TCPOpenGLFont.DrawText(X, Y: Single; Text: string; Color: TColor);
var
  I, Offset: Integer;
begin
  glPushMatrix;
  glTranslatef(X, Y, -1.0);
  Offset := FListIndex - Ord(FFirstGlyph);
  glColor3ub(Color and $FF, Color shr 8 and $FF, (Color shr 16 and $FF));
  for I := 1 to Length(Text) do
    glCallList(Ord(Text[I]) + Offset);
  glPopMatrix;
end;

procedure TCPOpenGLFont.FreeDisplayLists;
begin
  if (FListIndex <> -1) then
    glDeleteLists(FListIndex, FListCount);
  FListIndex := -1;
  FListCount := 0;
end;

procedure TCPOpenGLFont.FreeKerningTable;
var
  I: Integer;
begin
  for I := Low(FKerningTable) to High(FKerningTable) do
    Finalize(FKerningTable[I]);
  Finalize(FKerningTable);
end;

function TCPOpenGLFont.RoundToPowerOfTwo(Value: Integer): Integer;
begin
  Dec(Value);
  Value := Value or (Value shr 1);
  Value := Value or (Value shr 2);
  Value := Value or (Value shr 4);
  Value := Value or (Value shr 8);
  Value := Value or (Value shr 16);
  Inc(Value);
  Result := Value;
end;

procedure TCPOpenGLFont.SetFirstGlyph(const Value: Char);
begin
  if (FFirstGlyph <> Value) then
  begin
    FFirstGlyph := Value;
    UpdateGlyphCount;
  end;
end;

procedure TCPOpenGLFont.SetFont(const Value: TFont);
begin
  FFont := Value;
  BuildFont;
end;

procedure TCPOpenGLFont.SetLastGlyph(const Value: Char);
begin
  if (FLastGlyph <> Value) then
  begin
    FLastGlyph := Value;
    UpdateGlyphCount;
  end;
end;

procedure TCPOpenGLFont.UpdateGlyphCount;
begin
  FGlyphCount := Ord(FLastGlyph) - Ord(FFirstGlyph) + 1;
end;

end.
